{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Lirio.Base.AbsDuration
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Absolute duration note-list monad.
--
--------------------------------------------------------------------------------


module Lirio.Base.AbsDuration
  (
  
    DAbsolute
  , runNotelist

  , resetAll

  ) where

import Lirio.Base.CatDoc hiding ( newline )
import qualified Lirio.Base.CatDoc as C
import Lirio.Base.LyPrims
import Lirio.Base.Overloading
import Lirio.Base.Pitch

import Text.PrettyPrint.Leijen hiding ( dot )   -- package: wl-pprint

import Control.Applicative hiding ( empty )
import Data.Monoid hiding ( (<>) )


-- | In all likelihood we will have some state in the future...
--
newtype State ust = State { user_state :: ust }

-- | Initial values \"guaranteed\" not to match.
--
stateZero :: ust -> State ust
stateZero st = State { user_state = st }


newtype DAbsolute ust a = DAbsolute { 
    getDAbsolute :: State ust -> (a, State ust, CatDoc) }



instance Functor (DAbsolute ust) where
  fmap f ma = DAbsolute $ \s -> let (a,s1,w) = getDAbsolute ma s in (f a,s1,w)

instance Applicative (DAbsolute ust) where
  pure a    = DAbsolute $ \s -> (a,s,mempty)
  mf <*> ma = DAbsolute $ \s -> let (f,s1,w1) = getDAbsolute mf s
                                    (a,s2,w2) = getDAbsolute ma s1
                                in (f a, s2, w1 `mappend` w2)       

instance Monad (DAbsolute ust) where
  return   = pure
  ma >>= k = DAbsolute $ \s -> let (a,s1,w1) = getDAbsolute ma s 
                                   (b,s2,w2) = getDAbsolute (k a) s1
                               in (b, s2, w1 `mappend` w2)

instance Monoid a => Monoid (DAbsolute ust a) where
  mempty = pure mempty
  ma `mappend` mb = DAbsolute $ \s -> let (a,s1,w1) = getDAbsolute ma s
                                          (b,s2,w2) = getDAbsolute mb s1
                                      in (a `mappend` b,s2, w1 `mappend` w2)


-- instance CxReset DAbsolute where
--   reset = DAbsolute $ \_ -> ((), state_zero, mempty)



tellC :: CatDoc -> DAbsolute ust () 
tellC w = DAbsolute $ \s -> ((),s,w)

applyT :: (CatDoc -> CatDoc) -> DAbsolute ust a -> DAbsolute ust a
applyT fn ma = DAbsolute $ \s -> let (a,s1,w1) = getDAbsolute ma s
                                 in (a,s1, fn w1)   


{-
-- | DAbsolutes are /run/ within a Score.
--
notelist :: DAbsolute ust a -> Score ust a
notelist ma = withScore $ \s -> 
    let (a,s1,w) = getDAbsolute ma (stateZero s) in (a,s1, renderCatDoc w) 
-}


runNotelist :: ust -> DAbsolute ust a -> (a, ust, Doc) 
runNotelist ss ma = 
    let (a,s1,w) = getDAbsolute ma (stateZero ss) 
    in (a, user_state s1, renderCatDoc w)

resetAll :: ust -> DAbsolute ust ()
resetAll st = DAbsolute $ \_ -> ((), stateZero st, mempty)


--------------------------------------------------------------------------------
-- Overloading instances

instance HasCommandM (DAbsolute ust) where
  command = tellC . commandC 

instance HasNewlineM (DAbsolute ust) where
  newline = tellC $ C.newline

instance NoteListM (DAbsolute ust)

instance GenericMarkM (DAbsolute ust) where
  genericMark doc = tellC $ genericMarkC doc

instance GenericEventM (DAbsolute ust) where
  genericEvent doc d = tellC $ genericEventC doc (Just d)


instance HasRestM  (DAbsolute ust)
instance HasSpacerM (DAbsolute ust)



type instance Pch (DAbsolute ust) = Pitch


-- Note - NoteM and ChordM instances use the regular pitch type.
-- This does not prevent types that wrap DAbsolute ignoring these
-- instances and re-implementing them for a different pitch type.

instance NoteM (DAbsolute ust) where
  note p d = tellC $ noteC p (Just d)

instance ChordM (DAbsolute ust) where
  chord ps d = tellC $ chordC ps (Just d)


instance GroupingM (DAbsolute ust) where
  prefix d = applyT (C.prefix d)
  suffix d = applyT (C.suffix d)

